home *** CD-ROM | disk | FTP | other *** search
/ Precision Software Appli…tions Silver Collection 1 / Precision Software Applications Silver Collection Volume One (PSM) (1993).iso / tutor / ada1tutr.arj / ADA_TUTR.ADA next >
Text File  |  1992-09-04  |  26KB  |  519 lines

  1. -- ADA_TUTR.ADA   Ver. 2.02   4-SEP-1992   Copyright 1988-1992 John J. Herro
  2. -- Software Innovations Technology
  3. -- 1083 Mandarin Drive NE, Palm Bay, FL  32905-4706   (407)951-0233
  4. --
  5. -- Before compiling this file, you must compile ONE of the following:
  6. --
  7. --    JANUS.ADA     Recommended when using a PC with Janus/Ada.
  8. --    MERIDIAN.ADA  Recommended when using a PC with a Meridian Ada compiler
  9. --                     and the Meridian DOS Environment Library.
  10. --    UNIX.ADA      Recommended for UNIX based systems, if you can also
  11. --                     compile ONECHAR.C or ALTCHAR.C with a C compiler and
  12. --                     link with Ada.
  13. --    VAX.ADA       Recommended when using VAX Ada.
  14. --    VANILLA.ADA   "Plain vanilla" version for all other systems.  Should work
  15. --                     with ANY standard Ada compiler.  On some systems,
  16. --                     VANILLA.ADA may require you to strike ENTER after each
  17. --                     response.  However, you don't have to strike ENTER with
  18. --                     recent versions of TeleGen Ada by Telesoft.
  19. --
  20. -- See the PRINT.ME file for more information on installing ADA-TUTR on other
  21. -- computers.
  22. --
  23. --
  24. -- Before Running ADA-TUTR on a PC:
  25. --
  26. -- ADA-TUTR uses ANSI escape sequences for highlighting, cursor positioning,
  27. -- reverse video, etc.  Before ADA-TUTR will work correctly on a PC, you must
  28. -- install the device driver ANSI.SYS, which came with your copy of DOS.  To
  29. -- install ANSI.SYS, do the following:
  30. --
  31. -- 1.  If there's a file CONFIG.SYS in the root directory of the disk from
  32. --     which you boot, type it and look for a line saying "DEVICE=ANSI.SYS"
  33. --     (without the quotes), in either upper or lower case.  If that line isn't
  34. --     present, add it to CONFIG.SYS anywhere in the file, using an ordinary
  35. --     text editor or word processor in the non-document mode.  If there's no
  36. --     CONFIG.SYS file, create one containing the single line "DEVICE=ANSI.SYS"
  37. --     (without the quotes).
  38. --
  39. -- 2.  If there's no file ANSI.SYS in your root directory, copy ANSI.SYS from
  40. --     your DOS distribution diskette to the root directory of the disk from
  41. --     which you boot.
  42. --
  43. -- 3.  Reboot the computer.  ADA-TUTR should then work correctly.
  44. --
  45.  
  46. -- Introduction:
  47. --
  48. -- ADA-TUTR provides interactive instruction in the Ada programming language,
  49. -- allowing you to learn at your own pace.  On a PC, access to an Ada compiler
  50. -- is helpful, but not required.  You can exit this program at any time by
  51. -- striking X, and later resume the session exactly where you left off.  If you
  52. -- have a color monitor, you can set the foreground, background, and border
  53. -- colors at any time by typing S.
  54. --
  55. -- ADA-TUTR presents a screenful of information at a time.  Screens are read
  56. -- in 64-byte blocks from the random access file ADA_TUTR.DAT, using DIRECT_IO.
  57. -- For most screens, ADA-TUTR waits for you to strike one character to
  58. -- determine which screen to show next.  Screens are numbered starting with
  59. -- 101; each screen has a three-digit number.  Screens 101 through 108 have
  60. -- special uses, as follows:
  61. --
  62. -- 101 - This screen is presented when you complete the Ada course.  It
  63. --       contains a congratulatory message.  After this screen is shown,
  64. --       control returns directly to the operating system; the program doesn't
  65. --       wait for you to strike a character.
  66. -- 102 - This screen is presented when you exit ADA-TUTR before completing the
  67. --       course.  After this screen is shown, control returns directly to the
  68. --       operating system; the program doesn't wait for you to strike a
  69. --       character.
  70. -- 103 - This screen is shown whenever you strike X.  It displays the number of
  71. --       the last screen shown and the approximate percentage through the
  72. --       course.  It then asks if you want to exit the program.  If you strike
  73. --       Y, screen 102 is shown and control returns to the operating system.
  74. --       If you type N, screen 108 is shown to provide a menu of further
  75. --       choices.  From screen 103, you can also strike M to see the main menu
  76. --       (screen 106).
  77. -- 104 - This is the opening screen.  It asks if you've used ADA-TUTR before.
  78. --       If you strike N, a welcome screen is presented and the course begins.
  79. --       If you strike Y, screen 107 is shown.
  80. -- 105 - This screen allows you to type the number of the next screen you want
  81. --       to see.  For this screen, instead of striking one character, you type
  82. --       a three-digit number and presses ENTER.  Any number from 104 through
  83. --       the largest screen number is accepted.
  84. -- 106 - This screen contains the main menu of topics covered in ADA-TUTR.
  85. --       When you select a main topic, an appropriate sub-menu is shown.
  86. -- 107 - This screen is shown when you say that you've used ADA-TUTR before.
  87. --       It says "Welcome back!" and provides a menu that lets you resume where
  88. --       you left off, go back to the last question or Outside Assignment, go
  89. --       to the main menu (screen 106), or go to any specified screen number
  90. --       (via screen 105).
  91. -- 108 - This screen is shown when you answer N to screen 103.  It provides a
  92. --       menu similar to screen 107, except that the first choice takes you
  93. --       back to the screen shown before you saw 103.  For example, if you
  94. --       strike X while viewing screen 300, you'll see screen 103.  If you then
  95. --       answer N, you'll see screen 108.  From 108 the first menu selection
  96. --       takes you back to 300.
  97. --
  98.  
  99. -- Format of the Data File:
  100. --
  101. -- ADA-TUTR.DAT is a random access file of 64-byte blocks.  The format of this
  102. -- file changed considerably with version 2.00 of ADA-TUTR.  It's now much more
  103. -- compact, and, although it's still a data file, it now contains only the 95
  104. -- printable ASCII characters.
  105. --
  106. -- The first block of ADA_TUTR.DAT is referred to as block 1, and the first 31
  107. -- blocks together are called the index.  Bytes 2 through 4 of block 1 contain,
  108. -- in ASCII, the number of the welcome screen that's shown when you say that
  109. -- you haven't used ADA-TUTR before.  Bytes 6 through 8 of block 1 contain the
  110. -- number of the highest screen in the course.  (Bytes 1 and 5 of block 1
  111. -- contain spaces.)
  112. --
  113. -- Bytes 9 of block 1 through the end of block 31 contain four bytes of
  114. -- information for each of the possible screens 101 through 594.  For example,
  115. -- information for screen 101 is stored in bytes 9 through 12 of block 1, the
  116. -- next four bytes are for screen 102, etc.  For screens that don't exist, all
  117. -- four bytes contain spaces.
  118. --
  119. -- The first of the four bytes is A if the corresponding screen introduces an
  120. -- Outside Assignment, Q if the screen asks a question, or a space otherwise.
  121. -- The next two bytes give the number of the block where data for the screen
  122. -- begins, in base 95!  A space represents 0, ! represents 1, " represents 2,
  123. -- # represents 3, $ represents 4, etc., through all the printable characters
  124. -- of the ASCII set.  A tilde (~) represents 94.
  125. --
  126. -- The last of the four bytes gives the position, 1 through 64, within the
  127. -- block where the data for this screen starts.  Again, ! represents 1,
  128. -- " represents 2, # represents 3, etc.
  129. --
  130. -- Data for the screens are stored starting in position 1 of block 32.  In the
  131. -- screen data, the following characters have special meaning:
  132. --
  133. --           %  turns on high intensity.
  134. --           @  displays the number of spaces indicated by the next
  135. --                 character (# represents 3, $ represents 4, etc.)
  136. --           \  turns on reverse video and leaves one space.
  137. --           ^  turns on high intensity and leaves one space.
  138. --           `  restores normal video.
  139. --           {  causes CR-LF.
  140. --           }  moves cursor to row 24, column 1, for a prompt.
  141. --           ~  restores normal video and leaves one space.
  142. --
  143. -- These characters have special meaning in screen 103 only:
  144. --
  145. --           #  shows approximate percentage through the course.
  146. --           $  shows the number of the screen seen before 103.
  147. --
  148. -- Immediately after }, b represents "Please type a space to go on, or B to go
  149. -- back." and q represents "Please type a space to go on, or B or Q to go back
  150. -- to the question."
  151. --
  152.  
  153. --
  154. -- The data for each screen is followed by the "control information" for that
  155. -- screen, in square brackets.  The control information is a list of characters
  156. -- that you might strike after seeing this screen.  Each character is followed
  157. -- by the three-digit number of the next screen to be shown when that character
  158. -- is struck.  For example, Y107N120 is the control information for screen 104.
  159. -- This means that if you strike Y, screen 107 will be shown next, and if you
  160. -- strikes N, screen 120 will be shown.  Striking any other character will
  161. -- simply cause a beep (except that X can always be typed to exit the program,
  162. -- S can always be typed to set colors, and CR will be ignored).  If the
  163. -- control information is simply #, you are prompted to type the next screen
  164. -- number.  This feature is used in screen 105.
  165. --
  166. -- A "screen number" of 098 following a character means "go back to the last
  167. -- Outside Assignment," and 099 means "go back to the last question."  These
  168. -- special numbers are used in screens 107 and 108.  Number 100 means "go back
  169. -- to the previous screen seen."
  170. --
  171. -- ADA-TUTR opens the Data File in IN_FILE mode for read-only access.
  172. --
  173. --
  174. --
  175. -- Format of the User File:
  176. --
  177. -- The User File ADA_TUTR.USR initially doesn't exist.  It's created the first
  178. -- time ADA-TUTR is run.
  179. --
  180. -- ADA_TUTR.USR is a random access file containing one 64-byte block.  Bytes 2
  181. -- through 4 contain, in ASCII, the number of the last screen read the last
  182. -- time you ran ADA-TUTR.  Byte 6 contains a digit for the foreground color you
  183. -- select, byte 8 contains a digit for the background color, and byte 10
  184. -- contains a digit for the border color.  All other bytes contain spaces.  The
  185. -- ASCII characters '0' through '7' represent black, red, green, yellow, blue,
  186. -- magenta, cyan, and white, in that order.  Note that not all color PCs have a
  187. -- separate border color.  ADA_TUTR.USR is a random access file so that it can
  188. -- be easily updated by Ada.  It contains 64 bytes so that it can be accessed
  189. -- with the same package, namely RANDOM_IO, that accesses the Data File.
  190. --
  191. -- If the User File exists, ADA-TUTR opens it in INOUT_FILE mode for read/write
  192. -- access.  If it doesn't exist, ADA-TUTR creates it.
  193. --
  194.  
  195. with CUSTOM_IO, DIRECT_IO; use CUSTOM_IO;
  196. procedure ADA_TUTR is
  197.    subtype BLOCK_SUBTYPE is STRING(1 .. 64);
  198.    package RANDOM_IO is new DIRECT_IO(BLOCK_SUBTYPE); use RANDOM_IO;
  199.    DATA_FILE   : FILE_TYPE;            -- The file from which screens are read.
  200.    USER_FILE   : FILE_TYPE;          -- Remembers last screen seen, and colors.
  201.    BLOCK       : BLOCK_SUBTYPE;                -- Buffer for random-access I/O.
  202.    VPOS        : INTEGER;                       -- Number of the current block.
  203.    HPOS        : INTEGER;             -- Current position within current block.
  204.    SN, OLD_SN  : INTEGER := 104;        -- Screen num. and previous screen num.
  205.    QUITTING_SN : INTEGER := 104;           -- Screen number where you left off.
  206.    HIGHEST_SN  : INTEGER;               -- Highest screen number in the course.
  207.    WELCOME_SN  : INTEGER;           -- Number of the screen shown to new users.
  208.    INDX        : STRING(1 .. 1984);                -- Index from the Data File.
  209.    FILES_OK    : BOOLEAN := FALSE;        -- True when files open successfully.
  210.    LEGAL_NOTE  : constant STRING := " Copyright 1988-92 John J. Herro ";
  211.                        -- LEGAL_NOTE isn't used by the program, but it causes
  212.                        -- most compilers to place this string in the .EXE file.
  213.    procedure OPEN_DATA_FILE is separate;
  214.    procedure OPEN_USER_FILE is separate;
  215.    procedure SHOW_CURRENT_SCREEN is separate;
  216.    procedure GET_NEXT_SCREEN_NUMBER is separate;
  217. begin
  218.    OPEN_DATA_FILE;
  219.    OPEN_USER_FILE;
  220.    if FILES_OK then
  221.       SET_BORDER_COLOR(TO => BORDER_COLOR);              -- Set default colors.
  222.       PUT(NORMAL_COLORS);
  223.       while SN > 0 loop          -- "Screen number" of 0 means end the program.
  224.          PUT(CLEAR_SCRN);                                  -- Clear the screen.
  225.          SHOW_CURRENT_SCREEN;
  226.          GET_NEXT_SCREEN_NUMBER;
  227.       end loop;
  228.       BLOCK := (others => ' ');       -- Write user-specific data to user file.
  229.       BLOCK(1 .. 4) := INTEGER'IMAGE(QUITTING_SN);
  230.       BLOCK(6)  := FORE_COLOR_DIGIT;
  231.       BLOCK(8)  := BACK_COLOR_DIGIT;
  232.       BLOCK(10) := CHARACTER'VAL(COLOR'POS(BORDER_COLOR) + 48);
  233.       WRITE(USER_FILE, ITEM => BLOCK, TO => 1);
  234.       CLOSE(DATA_FILE);
  235.       CLOSE(USER_FILE);
  236.    end if;
  237. end ADA_TUTR;
  238.  
  239. separate (ADA_TUTR)
  240. procedure OPEN_DATA_FILE is
  241.    DATA_FILE_NAME : constant STRING := "ADA_TUTR.DAT";
  242. begin
  243.    OPEN(DATA_FILE, MODE => IN_FILE, NAME => DATA_FILE_NAME);
  244.    for I in 1 .. 31 loop                 -- Read index from start of Data File.
  245.       READ(DATA_FILE, ITEM => BLOCK, FROM => COUNT(I));
  246.       INDX(64*I - 63 .. 64*I) := BLOCK;
  247.    end loop;
  248.    WELCOME_SN := INTEGER'VALUE(INDX(2 .. 4));
  249.    HIGHEST_SN := INTEGER'VALUE(INDX(6 .. 8));
  250.    FILES_OK := TRUE;
  251. exception
  252.    when NAME_ERROR =>
  253.       PUT("I'm sorry.  The file " & DATA_FILE_NAME);
  254.       PUT_LINE(" seems to be missing.");
  255.    when others =>
  256.       PUT("I'm sorry.  The file " & DATA_FILE_NAME);
  257.       PUT_LINE(" seems to have the wrong form.");
  258. end OPEN_DATA_FILE;
  259.  
  260.  
  261.  
  262. separate (ADA_TUTR)
  263. procedure OPEN_USER_FILE is
  264.    USER_FILE_NAME : constant STRING := "ADA_TUTR.USR";
  265. begin
  266.    OPEN(USER_FILE, MODE => INOUT_FILE, NAME => USER_FILE_NAME);
  267.    READ(USER_FILE, ITEM => BLOCK, FROM => 1);
  268.    QUITTING_SN      := INTEGER'VALUE(BLOCK(1 .. 4));
  269.    OLD_SN           := QUITTING_SN;
  270.    FOREGRND_COLOR   := COLOR'VAL(INTEGER'VALUE(BLOCK(5 .. 6)));
  271.    BACKGRND_COLOR   := COLOR'VAL(INTEGER'VALUE(BLOCK(7 .. 8)));
  272.    BORDER_COLOR     := COLOR'VAL(INTEGER'VALUE(BLOCK(9 .. 10)));
  273.    FORE_COLOR_DIGIT := BLOCK(6);
  274.    BACK_COLOR_DIGIT := BLOCK(8);
  275.    NORMAL_COLORS(6) := FORE_COLOR_DIGIT;
  276.    NORMAL_COLORS(9) := BACK_COLOR_DIGIT;
  277. exception
  278.    when NAME_ERROR =>
  279.       begin
  280.          CREATE(USER_FILE, MODE => INOUT_FILE, NAME => USER_FILE_NAME);
  281.       exception
  282.          when others =>
  283.             PUT("I'm sorry.  I couldn't find or create ");
  284.             PUT_LINE(USER_FILE_NAME);
  285.             FILES_OK := FALSE;
  286.       end;
  287.    when others =>
  288.       PUT_LINE("I'm sorry.  The file " & USER_FILE_NAME & " seems to have");
  289.       PUT_LINE("the wrong form or contain bad data.");
  290.       PUT_LINE("You might want to delete the file and try again.");
  291.       PUT_LINE("(Default values will be used.)");
  292.       FILES_OK := FALSE;
  293. end OPEN_USER_FILE;
  294.  
  295. separate (ADA_TUTR)
  296. procedure SHOW_CURRENT_SCREEN is
  297.    HALF_DIFF : INTEGER := (HIGHEST_SN - WELCOME_SN) / 2;
  298.    PERCENT   : INTEGER := (50 * (OLD_SN - WELCOME_SN)) / HALF_DIFF;
  299.                           -- Percentage of the course completed.  Using 50 and
  300.                           -- HALF_DIFF guarantees that the numerator < 2 ** 15.
  301.    EXPANDING : BOOLEAN := FALSE;        -- True when expanding multiple spaces.
  302.    PROMPTING : BOOLEAN := FALSE;       -- True for first character in a prompt.
  303.    SPACE     : constant STRING(1 .. 80) := (others => ' ');
  304.    procedure PROCESS_CHAR is separate;
  305. begin
  306.    VPOS := 95*(CHARACTER'POS(INDX(SN*4 - 394)) - 32) +        -- Point to start
  307.                CHARACTER'POS(INDX(SN*4 - 393)) - 32;          -- of current
  308.    HPOS := CHARACTER'POS(INDX(SN*4 - 392)) - 32;              -- screen.
  309.    READ(DATA_FILE, ITEM => BLOCK, FROM => COUNT(VPOS));
  310.    if PERCENT < 0 then                      -- Make sure PERCENT is reasonable.
  311.       PERCENT := 0;
  312.    elsif PERCENT > 99 then
  313.       PERCENT := 99;
  314.    end if;
  315.    while BLOCK(HPOS) /= '[' or EXPANDING loop     -- [ starts the control info.
  316.       if EXPANDING then
  317.          PUT(SPACE(1 .. CHARACTER'POS(BLOCK(HPOS)) - 32));
  318.          EXPANDING := FALSE;
  319.       elsif PROMPTING then
  320.          case BLOCK(HPOS) is
  321.             when 'b' => PUT("Please type a space to go on, or B to go back.");
  322.             when 'q' => PUT("Please type a space to go on, or B or Q to go ");
  323.                         PUT("back to the question.");
  324.             when others => PROCESS_CHAR;
  325.          end case;
  326.          PROMPTING := FALSE;
  327.       else
  328.          PROCESS_CHAR;
  329.       end if;
  330.       HPOS := HPOS + 1;
  331.       if HPOS > BLOCK'LENGTH then
  332.          VPOS := VPOS + 1;
  333.          HPOS := 1;
  334.          READ(DATA_FILE, ITEM => BLOCK, FROM => COUNT(VPOS));
  335.       end if;
  336.    end loop;
  337. end SHOW_CURRENT_SCREEN;
  338.  
  339. separate (ADA_TUTR.SHOW_CURRENT_SCREEN)
  340. procedure PROCESS_CHAR is
  341. begin
  342.    case BLOCK(HPOS) is
  343.       when '{'    => NEW_LINE;                           -- { = CR-LF.
  344.       when '@'    => EXPANDING := TRUE;                  -- @ = several spaces.
  345.       when '^'    => PUT(ASCII.ESC & "[1m ");            -- ^ = bright + space.
  346.       when '~'    => PUT(NORMAL_COLORS & ' ');           -- ~ = normal + space.
  347.       when '%'    => PUT(ASCII.ESC & "[1m");             -- % = bright.
  348.       when '`'    => PUT(NORMAL_COLORS);                 -- ` = normal.
  349.       when '}'    => PUT(ASCII.ESC & "[24;1H");          -- } = go to line 24.
  350.                      PROMPTING := TRUE;
  351.       when '\'    => PUT(ASCII.ESC & "[7m ");            -- \ = rev. vid. + sp.
  352.       when '$'    => if SN = 103 then                    -- $ = screen #.
  353.                         PUT(INTEGER'IMAGE(OLD_SN));
  354.                      else
  355.                         PUT('$');
  356.                      end if;
  357.       when '#'    => if SN = 103 then                    -- # = % completed.
  358.                         PUT(INTEGER'IMAGE(PERCENT));
  359.                      else
  360.                         PUT('#');
  361.                      end if;
  362.       when others => PUT(BLOCK(HPOS));
  363.    end case;
  364. end PROCESS_CHAR;
  365.  
  366. separate (ADA_TUTR)
  367. procedure GET_NEXT_SCREEN_NUMBER is
  368.    CTRL_INFO : BLOCK_SUBTYPE;          -- Control info. for the current screen.
  369.    PLACE     : INTEGER := 1;              -- Current position within CTRL_INFO.
  370.    INPUT     : STRING(1 .. 4);                  -- Screen number that you type.
  371.    LEN       : INTEGER;                            -- Length of typed response.
  372.    VALID     : BOOLEAN;                   -- True when typed response is valid.
  373.    procedure SET_COLORS is separate;
  374.    procedure INPUT_ONE_KEYSTROKE is separate;
  375. begin
  376.    while BLOCK(HPOS) /= ']' loop    -- Read control information from Data File.
  377.       HPOS := HPOS + 1;
  378.       if HPOS > BLOCK'LENGTH then
  379.          VPOS := VPOS + 1;
  380.          HPOS := 1;
  381.          READ(DATA_FILE, ITEM => BLOCK, FROM => COUNT(VPOS));
  382.       end if;
  383.       CTRL_INFO(PLACE) := BLOCK(HPOS);
  384.       PLACE := PLACE + 1;
  385.    end loop;
  386.    if SN = 103 then                    -- Screen 103 means you typed X to exit.
  387.       QUITTING_SN := OLD_SN;
  388.    elsif SN >= WELCOME_SN then              -- Save SN so you can return to it.
  389.       OLD_SN := SN;
  390.    end if;
  391.    if SN < 103 then                          -- Set SN to # of the next screen.
  392.       SN := 0;      -- Set signal to end the program after screens 101 and 102.
  393.    elsif CTRL_INFO(1) = '#' then            -- You type the next screen number.
  394.       VALID := FALSE;
  395.       while not VALID loop              -- Keep trying until response is valid.
  396.          PUT("# ");                                -- Prompt for screen number.
  397.          INPUT := "    ";  GET_LINE(INPUT, LEN);        -- Input screen number.
  398.          if INPUT(1) = 'x' or INPUT(1) = 'X' or INPUT(1) = ASCII.ETX then
  399.             SN := 103;                        -- Show screen 103 if you type X.
  400.             VALID := TRUE;                            -- X is a valid response.
  401.          elsif INPUT(1) = 's' or INPUT(1) = 'S' then
  402.             SET_COLORS;                            -- Set colors if you type S.
  403.             VALID := TRUE;                            -- S is a valid response.
  404.          else
  405.             begin                                    -- Convert ASCII input to
  406.                SN := INTEGER'VALUE(INPUT);           -- integer.  If in range,
  407.                VALID := SN in 104 .. HIGHEST_SN;     -- set VALID to TRUE.  If
  408.             exception                                -- it can't be converted
  409.                when others => null;                  -- (e.g., illegal char.),
  410.             end;                                     -- or it's out of range,
  411.          end if;                                     -- leave VALID = FALSE so
  412.          if not VALID and LEN > 0 then               -- you can try again.
  413.             PUT_LINE("Incorrect number.  Please try again.");
  414.          end if;
  415.       end loop;
  416.    else
  417.       INPUT_ONE_KEYSTROKE;
  418.    end if;
  419. end GET_NEXT_SCREEN_NUMBER;
  420.  
  421. separate (ADA_TUTR.GET_NEXT_SCREEN_NUMBER)
  422. procedure SET_COLORS is
  423.    BRIGHT    : constant STRING := ASCII.ESC & "[1m";  -- Causes high intensity.
  424.    KEYSTROKE : CHARACTER := 'f';             -- Single character that you type.
  425.    SPACE     : constant STRING(1 .. 23) := (others => ' ');
  426. begin
  427.    while KEYSTROKE = 'f' or KEYSTROKE = 'b' or KEYSTROKE = 'r' or
  428.          KEYSTROKE = 'F' or KEYSTROKE = 'B' or KEYSTROKE = 'R' loop
  429.       PUT(CLEAR_SCRN);                                     -- Clear the screen.
  430.       NEW_LINE;
  431.       PUT(SPACE & "The " & BRIGHT & "foreground" & NORMAL_COLORS);
  432.       PUT_LINE(" color is now " & COLOR'IMAGE(FOREGRND_COLOR) & '.');
  433.       PUT(SPACE & "The " & BRIGHT & "background" & NORMAL_COLORS);
  434.       PUT_LINE(" color is now " & COLOR'IMAGE(BACKGRND_COLOR) & '.');
  435.       PUT(SPACE & "The " & BRIGHT & "  border  " & NORMAL_COLORS);
  436.       PUT_LINE(" color is now " & COLOR'IMAGE(BORDER_COLOR) & '.');
  437.       NEW_LINE;
  438.       PUT_LINE(SPACE & " Note:  Some color PCs don't have");
  439.       PUT_LINE(SPACE & "     separate border colors.");
  440.       NEW_LINE;
  441.       PUT_LINE(SPACE & "             Strike:");
  442.       PUT_LINE(SPACE & "F to change the foreground color,");
  443.       PUT_LINE(SPACE & "B to change the background color,");
  444.       PUT_LINE(SPACE & "R to change the   border   color.");
  445.       NEW_LINE;
  446.       PUT_LINE(SPACE & "Strike any other key to continue.");
  447.       GET(KEYSTROKE);                       -- Get one character from keyboard.
  448.       if KEYSTROKE = 'f' or KEYSTROKE = 'F' then
  449.          FOREGRND_COLOR := COLOR'VAL((COLOR'POS(FOREGRND_COLOR) + 1) mod 8);
  450.          if FOREGRND_COLOR = BACKGRND_COLOR then
  451.             FOREGRND_COLOR := COLOR'VAL((COLOR'POS(FOREGRND_COLOR) + 1) mod 8);
  452.          end if;
  453.       elsif KEYSTROKE = 'b' or KEYSTROKE = 'B' then
  454.          BACKGRND_COLOR := COLOR'VAL((COLOR'POS(BACKGRND_COLOR) + 1) mod 8);
  455.          if FOREGRND_COLOR = BACKGRND_COLOR then
  456.             BACKGRND_COLOR := COLOR'VAL((COLOR'POS(BACKGRND_COLOR) + 1) mod 8);
  457.          end if;
  458.       elsif KEYSTROKE = 'r' or KEYSTROKE = 'R' then
  459.          BORDER_COLOR := COLOR'VAL((COLOR'POS(BORDER_COLOR) + 1) mod 8);
  460.       end if;
  461.       FORE_COLOR_DIGIT := CHARACTER'VAL(48 + COLOR'POS(FOREGRND_COLOR));
  462.       BACK_COLOR_DIGIT := CHARACTER'VAL(48 + COLOR'POS(BACKGRND_COLOR));
  463.       NORMAL_COLORS(6) := FORE_COLOR_DIGIT;
  464.       NORMAL_COLORS(9) := BACK_COLOR_DIGIT;
  465.       PUT(NORMAL_COLORS);
  466.       SET_BORDER_COLOR(TO => BORDER_COLOR);
  467.    end loop;
  468. end SET_COLORS;
  469.  
  470. separate (ADA_TUTR.GET_NEXT_SCREEN_NUMBER)
  471. procedure INPUT_ONE_KEYSTROKE is
  472.    KEYSTROKE : CHARACTER;                    -- Single character that you type.
  473.    VALID     : BOOLEAN := FALSE;          -- True when typed response is valid.
  474.    WHERE     : INTEGER;              -- Location of control block in Data File.
  475.    SEARCH    : CHARACTER;    -- 'A' = last Outside Assignment; 'Q' = last Ques.
  476. begin
  477.    PUT("  >");                                     -- Prompt for one character.
  478.    while not VALID loop                 -- Keep trying until response is valid.
  479.       GET(KEYSTROKE);                       -- Get one character from keyboard.
  480.       if KEYSTROKE in 'a' .. 'z' then          -- Force upper case to simplify.
  481.          KEYSTROKE := CHARACTER'VAL(CHARACTER'POS(KEYSTROKE) - 32);
  482.       end if;
  483.       if KEYSTROKE = 'X' or KEYSTROKE = ASCII.ETX then
  484.          SN := 103;                           -- Show screen 103 if you type X.
  485.          VALID := TRUE;                               -- X is a valid response.
  486.       elsif KEYSTROKE = 'S' then
  487.          SET_COLORS;                               -- Set colors if you type S.
  488.          VALID := TRUE;                               -- S is a valid response.
  489.       end if;
  490.       PLACE := 1;           -- Search list of valid characters for this screen.
  491.       VALID := VALID;             -- This statement works around a minor bug in
  492.                                   -- ver. 1.0 of the Meridian IFORM optimizer.
  493.       while not VALID and CTRL_INFO(PLACE) /= ']' loop      -- ] ends the list.
  494.          if KEYSTROKE = CTRL_INFO(PLACE) then
  495.                   -- Typed char. found in list; get screen # from control info.
  496.             SN := INTEGER'VALUE(CTRL_INFO(PLACE + 1 .. PLACE + 3));
  497.             VALID := TRUE;   -- Characters in the list are all valid responses.
  498.          end if;
  499.          PLACE := PLACE + 4;    -- A 3-digit number follows each char. in list.
  500.       end loop;
  501.       if not VALID and KEYSTROKE /= ASCII.CR then        -- Beep if response is
  502.          PUT(ASCII.BEL);                                 -- not valid, but
  503.       end if;                                            -- ignore CRs quietly.
  504.    end loop;
  505.    if SN = 98 then                       -- Go back to last Outside Assignment.
  506.       SEARCH := 'A';
  507.    elsif SN = 99 then                              -- Go back to last question.
  508.       SEARCH := 'Q';
  509.    elsif SN = 100 then                      -- Go back to the last screen seen.
  510.       SN := QUITTING_SN;
  511.    end if;
  512.    if SN = 98 or SN = 99 then
  513.       SN := OLD_SN;
  514.       while SN > WELCOME_SN and INDX(SN*4 - 395) /= SEARCH loop
  515.          SN := SN - 1;
  516.       end loop;
  517.    end if;
  518. end INPUT_ONE_KEYSTROKE;
  519.